home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / lib / perl5 / Net / DBus / Binding / Introspector.pm < prev    next >
Encoding:
Perl POD Document  |  2008-02-20  |  32.8 KB  |  1,207 lines
  1. # -*- perl -*-
  2. #
  3. # Copyright (C) 2004-2006 Daniel P. Berrange
  4. #
  5. # This program is free software; You can redistribute it and/or modify
  6. # it under the same terms as Perl itself. Either:
  7. #
  8. # a) the GNU General Public License as published by the Free
  9. #   Software Foundation; either version 2, or (at your option) any
  10. #   later version,
  11. #
  12. # or
  13. #
  14. # b) the "Artistic License"
  15. #
  16. # The file "COPYING" distributed along with this file provides full
  17. # details of the terms and conditions of the two licenses.
  18.  
  19. =pod
  20.  
  21. =head1 NAME
  22.  
  23. Net::DBus::Binding::Introspector - Handler for object introspection data
  24.  
  25. =head1 SYNOPSIS
  26.  
  27.   # Create an object populating with info from an
  28.   # XML doc containing introspection data.
  29.  
  30.   my $ins = Net::DBus::Binding::Introspector->new(xml => $data);
  31.  
  32.   # Create an object, defining introspection data
  33.   # programmatically
  34.   my $ins = Net::DBus::Binding::Introspector->new(object_path => $object->get_object_path);
  35.   $ins->add_method("DoSomething", ["string"], [], "org.example.MyObject");
  36.   $ins->add_method("TestSomething", ["int32"], [], "org.example.MyObject");
  37.  
  38. =head1 DESCRIPTION
  39.  
  40. This class is responsible for managing introspection data, and
  41. answering questions about it. This is not intended for use by
  42. application developers, whom should instead consult the higher
  43. level API in L<Net::DBus::Exporter>.
  44.  
  45. =head1 METHODS
  46.  
  47. =over 4
  48.  
  49. =cut
  50.  
  51. package Net::DBus::Binding::Introspector;
  52.  
  53. use 5.006;
  54. use strict;
  55. use warnings;
  56.  
  57. use XML::Twig;
  58.  
  59. use Net::DBus::Binding::Message;
  60.  
  61. our $debug = 0;
  62.  
  63. BEGIN {
  64.     if ($ENV{NET_DBUS_DEBUG} &&
  65.     $ENV{NET_DBUS_DEBUG} eq "introspect") {
  66.     $debug = 1;
  67.     }
  68. }
  69.  
  70. our %simple_type_map = (
  71.   "byte" => &Net::DBus::Binding::Message::TYPE_BYTE,
  72.   "bool" => &Net::DBus::Binding::Message::TYPE_BOOLEAN,
  73.   "double" => &Net::DBus::Binding::Message::TYPE_DOUBLE,
  74.   "string" => &Net::DBus::Binding::Message::TYPE_STRING,
  75.   "int16" => &Net::DBus::Binding::Message::TYPE_INT16,
  76.   "uint16" => &Net::DBus::Binding::Message::TYPE_UINT16,
  77.   "int32" => &Net::DBus::Binding::Message::TYPE_INT32,
  78.   "uint32" => &Net::DBus::Binding::Message::TYPE_UINT32,
  79.   "int64" => &Net::DBus::Binding::Message::TYPE_INT64,
  80.   "uint64" => &Net::DBus::Binding::Message::TYPE_UINT64,
  81.   "objectpath" => &Net::DBus::Binding::Message::TYPE_OBJECT_PATH,
  82.   "signature" => &Net::DBus::Binding::Message::TYPE_SIGNATURE,
  83. );
  84.  
  85. our %simple_type_rev_map = (
  86.   &Net::DBus::Binding::Message::TYPE_BYTE => "byte",
  87.   &Net::DBus::Binding::Message::TYPE_BOOLEAN => "bool",
  88.   &Net::DBus::Binding::Message::TYPE_DOUBLE => "double",
  89.   &Net::DBus::Binding::Message::TYPE_STRING => "string",
  90.   &Net::DBus::Binding::Message::TYPE_INT16 => "int16",
  91.   &Net::DBus::Binding::Message::TYPE_UINT16 => "uint16",
  92.   &Net::DBus::Binding::Message::TYPE_INT32 => "int32",
  93.   &Net::DBus::Binding::Message::TYPE_UINT32 => "uint32",
  94.   &Net::DBus::Binding::Message::TYPE_INT64 => "int64",
  95.   &Net::DBus::Binding::Message::TYPE_UINT64 => "uint64",
  96.   &Net::DBus::Binding::Message::TYPE_OBJECT_PATH => "objectpath",
  97.   &Net::DBus::Binding::Message::TYPE_SIGNATURE => "signature",
  98. );
  99.  
  100. our %magic_type_map = (
  101.   "caller" => sub {
  102.     my $msg = shift;
  103.  
  104.     return $msg->get_sender;
  105.   },
  106.   "serial" => sub {
  107.     my $msg = shift;
  108.  
  109.     return $msg->get_serial;
  110.   },
  111. );
  112.  
  113. our %compound_type_map = (
  114.   "array" => &Net::DBus::Binding::Message::TYPE_ARRAY,
  115.   "struct" => &Net::DBus::Binding::Message::TYPE_STRUCT,
  116.   "dict" => &Net::DBus::Binding::Message::TYPE_DICT_ENTRY,
  117.   "variant" => &Net::DBus::Binding::Message::TYPE_VARIANT,
  118. );
  119.  
  120. =item my $ins = Net::DBus::Binding::Introspector->new(object_path => $object_path,
  121.                               xml => $xml);
  122.  
  123. Creates a new introspection data manager for the object registered
  124. at the path specified for the C<object_path> parameter. The optional
  125. C<xml> parameter can be used to pre-load the manager with introspection
  126. metadata from an XML document.
  127.  
  128. =cut
  129.  
  130. sub new {
  131.     my $proto = shift;
  132.     my $class = ref($proto) || $proto;
  133.     my $self = {};
  134.     my %params = @_;
  135.  
  136.     $self->{interfaces} = {};
  137.  
  138.     bless $self, $class;
  139.  
  140.     if (defined $params{xml}) {
  141.     $self->{object_path} = exists $params{object_path} ? $params{object_path} : undef;
  142.     $self->_parse($params{xml});
  143.     } elsif (defined $params{node}) {
  144.     $self->{object_path} = exists $params{object_path} ? $params{object_path} : undef;
  145.     $self->_parse_node($params{node});
  146.     } else {
  147.     $self->{object_path} = exists $params{object_path} ? $params{object_path} : undef;
  148.     $self->{interfaces} = $params{interfaces} if exists $params{interfaces};
  149.     $self->{children} = exists $params{children} ? $params{children} : [];
  150.     }
  151.  
  152.     # Some versions of dbus failed to include signals in introspection data
  153.     # so this code adds them, letting us keep compatability with old versions
  154.     if (defined $self->{object_path} &&
  155.     $self->{object_path} eq "/org/freedesktop/DBus") {
  156.     if (!$self->has_signal("NameOwnerChanged")) {
  157.         $self->add_signal("NameOwnerChanged", ["string","string","string"], "org.freedesktop.DBus");
  158.     }
  159.     if (!$self->has_signal("NameLost")) {
  160.         $self->add_signal("NameLost", ["string"], "org.freedesktop.DBus");
  161.     }
  162.     if (!$self->has_signal("NameAcquired")) {
  163.         $self->add_signal("NameAcquired", ["string"], "org.freedesktop.DBus");
  164.     }
  165.     }
  166.  
  167.     return $self;
  168. }
  169.  
  170. =item $ins->add_interface($name)
  171.  
  172. Register the object as providing an interface with the name C<$name>
  173.  
  174. =cut
  175.  
  176. sub add_interface {
  177.     my $self = shift;
  178.     my $name = shift;
  179.  
  180.     $self->{interfaces}->{$name} = {
  181.     methods => {},
  182.     signals => {},
  183.     props => {},
  184.     } unless exists $self->{interfaces}->{$name};
  185. }
  186.  
  187. =item my $bool = $ins->has_interface($name)
  188.  
  189. Return a true value if the object is registered as providing
  190. an interface with the name C<$name>; returns false otherwise.
  191.  
  192. =cut
  193.  
  194. sub has_interface {
  195.     my $self = shift;
  196.     my $name = shift;
  197.  
  198.     return exists $self->{interfaces}->{$name} ? 1 : 0;
  199. }
  200.  
  201. =item my @interfaces = $ins->has_method($name)
  202.  
  203. Return a list of all interfaces provided by the object, which
  204. contain a method called C<$name>. This may be an empty list.
  205.  
  206. =cut
  207.  
  208. sub has_method {
  209.     my $self = shift;
  210.     my $name = shift;
  211.  
  212.     my @interfaces;
  213.     foreach my $interface (keys %{$self->{interfaces}}) {
  214.     if (exists $self->{interfaces}->{$interface}->{methods}->{$name}) {
  215.         push @interfaces, $interface;
  216.     }
  217.     }
  218.  
  219.     return @interfaces;
  220. }
  221.  
  222. =item my @interfaces = $ins->has_signal($name)
  223.  
  224. Return a list of all interfaces provided by the object, which
  225. contain a signal called C<$name>. This may be an empty list.
  226.  
  227. =cut
  228.  
  229. sub has_signal {
  230.     my $self = shift;
  231.     my $name = shift;
  232.  
  233.     my @interfaces;
  234.     foreach my $interface (keys %{$self->{interfaces}}) {
  235.     if (exists $self->{interfaces}->{$interface}->{signals}->{$name}) {
  236.         push @interfaces, $interface;
  237.     }
  238.     }
  239.     return @interfaces;
  240. }
  241.  
  242. =item my @interfaces = $ins->has_property($name)
  243.  
  244. Return a list of all interfaces provided by the object, which
  245. contain a property called C<$name>. This may be an empty list.
  246.  
  247. =cut
  248.  
  249. sub has_property {
  250.     my $self = shift;
  251.     my $name = shift;
  252.  
  253.     if (@_) {
  254.     my $interface = shift;
  255.     return () unless exists $self->{interfaces}->{$interface};
  256.     return () unless exists $self->{interfaces}->{$interface}->{props}->{$name};
  257.     return ($interface);
  258.     } else {
  259.     my @interfaces;
  260.     foreach my $interface (keys %{$self->{interfaces}}) {
  261.         if (exists $self->{interfaces}->{$interface}->{props}->{$name}) {
  262.         push @interfaces, $interface;
  263.         }
  264.     }
  265.     return @interfaces;
  266.     }
  267. }
  268.  
  269. =item $ins->add_method($name, $params, $returns, $interface, $attributes, $paramnames, $returnnames);
  270.  
  271. Register the object as providing a method called C<$name> accepting parameters
  272. whose types are declared by C<$params> and returning values whose type
  273. are declared by C<$returns>. The method will be scoped to the inteface
  274. named by C<$interface>. The C<$attributes> parameter is a hash reference
  275. for annotating the method. The C<$paramnames> and C<$returnames> parameters
  276. are a list of argument and return value names.
  277.  
  278. =cut
  279.  
  280. sub add_method {
  281.     my $self = shift;
  282.     my $name = shift;
  283.     my $params = shift;
  284.     my $returns = shift;
  285.     my $interface = shift;
  286.     my $attributes = shift;
  287.     my $paramnames = shift;
  288.     my $returnnames = shift;
  289.  
  290.     $self->add_interface($interface);
  291.     $self->{interfaces}->{$interface}->{methods}->{$name} = {
  292.     params => $params,
  293.     returns => $returns,
  294.     paramnames => $paramnames,
  295.     returnnames => $returnnames,
  296.     deprecated => $attributes->{deprecated} ? 1 : 0,
  297.     no_reply => $attributes->{no_return} ? 1 : 0,
  298.     };
  299. }
  300.  
  301. =item $ins->add_signal($name, $params, $interface, $attributes);
  302.  
  303. Register the object as providing a signal called C<$name> with parameters
  304. whose types are declared by C<$params>. The signal will be scoped to the inteface
  305. named by C<$interface>. The C<$attributes> parameter is a hash reference
  306. for annotating the signal.
  307.  
  308. =cut
  309.  
  310. sub add_signal {
  311.     my $self = shift;
  312.     my $name = shift;
  313.     my $params = shift;
  314.     my $interface = shift;
  315.     my $attributes = shift;
  316.     my $paramnames = shift;
  317.  
  318.     $self->add_interface($interface);
  319.     $self->{interfaces}->{$interface}->{signals}->{$name} = {
  320.     params => $params,
  321.     paramnames => $paramnames,
  322.     deprecated => $attributes->{deprecated} ? 1 : 0,
  323.     };
  324. }
  325.  
  326. =item $ins->add_property($name, $type, $access, $interface, $attributes);
  327.  
  328. Register the object as providing a property called C<$name> with a type
  329. of C<$type>. The C<$access> parameter can be one of C<read>, C<write>,
  330. or C<readwrite>. The property will be scoped to the inteface
  331. named by C<$interface>. The C<$attributes> parameter is a hash reference
  332. for annotating the signal.
  333.  
  334. =cut
  335.  
  336. sub add_property {
  337.     my $self = shift;
  338.     my $name = shift;
  339.     my $type = shift;
  340.     my $access = shift;
  341.     my $interface = shift;
  342.     my $attributes = shift;
  343.  
  344.     $self->add_interface($interface);
  345.     $self->{interfaces}->{$interface}->{props}->{$name} = {
  346.     type => $type,
  347.     access => $access,
  348.     deprecated => $attributes->{deprecated} ? 1 : 0,
  349.     };
  350. }
  351.  
  352. =item my $boolean = $ins->is_method_deprecated($name, $interface)
  353.  
  354. Returns a true value if the method called C<$name> in the interface
  355. C<$interface> is marked as deprecated
  356.  
  357. =cut
  358.  
  359. sub is_method_deprecated {
  360.     my $self = shift;
  361.     my $name = shift;
  362.     my $interface = shift;
  363.  
  364.     die "no interface $interface" unless exists $self->{interfaces}->{$interface};
  365.     die "no method $name in interface $interface" unless exists $self->{interfaces}->{$interface}->{methods}->{$name};
  366.     return 1 if $self->{interfaces}->{$interface}->{methods}->{$name}->{deprecated};
  367.     return 0;
  368. }
  369.  
  370. =item my $boolean = $ins->is_signal_deprecated($name, $interface)
  371.  
  372. Returns a true value if the signal called C<$name> in the interface
  373. C<$interface> is marked as deprecated
  374.  
  375. =cut
  376.  
  377. sub is_signal_deprecated {
  378.     my $self = shift;
  379.     my $name = shift;
  380.     my $interface = shift;
  381.  
  382.     die "no interface $interface" unless exists $self->{interfaces}->{$interface};
  383.     die "no signal $name in interface $interface" unless exists $self->{interfaces}->{$interface}->{signals}->{$name};
  384.     return 1 if $self->{interfaces}->{$interface}->{signals}->{$name}->{deprecated};
  385.     return 0;
  386. }
  387.  
  388. =item my $boolean = $ins->is_property_deprecated($name, $interface)
  389.  
  390. Returns a true value if the property called C<$name> in the interface
  391. C<$interface> is marked as deprecated
  392.  
  393. =cut
  394.  
  395. sub is_property_deprecated {
  396.     my $self = shift;
  397.     my $name = shift;
  398.     my $interface = shift;
  399.  
  400.     die "no interface $interface" unless exists $self->{interfaces}->{$interface};
  401.     die "no property $name in interface $interface" unless exists $self->{interfaces}->{$interface}->{props}->{$name};
  402.     return 1 if $self->{interfaces}->{$interface}->{props}->{$name}->{deprecated};
  403.     return 0;
  404. }
  405.  
  406. =item my $boolean = $ins->does_method_reply($name, $interface)
  407.  
  408. Returns a true value if the method called C<$name> in the interface
  409. C<$interface> will generate a reply. Returns a false value otherwise.
  410.  
  411. =cut
  412.  
  413. sub does_method_reply {
  414.     my $self = shift;
  415.     my $name = shift;
  416.     my $interface = shift;
  417.  
  418.     die "no interface $interface" unless exists $self->{interfaces}->{$interface};
  419.     die "no method $name in interface $interface" unless exists $self->{interfaces}->{$interface}->{methods}->{$name};
  420.     return 0 if $self->{interfaces}->{$interface}->{methods}->{$name}->{no_reply};
  421.     return 1;
  422. }
  423.  
  424. =item my @names = $ins->list_interfaces
  425.  
  426. Returns a list of all interfaces registered as being provided
  427. by the object.
  428.  
  429. =cut
  430.  
  431. sub list_interfaces {
  432.     my $self = shift;
  433.  
  434.     return keys %{$self->{interfaces}};
  435. }
  436.  
  437. =item my @names = $ins->list_methods($interface)
  438.  
  439. Returns a list of all methods registered as being provided
  440. by the object, within the interface C<$interface>.
  441.  
  442. =cut
  443.  
  444. sub list_methods {
  445.     my $self = shift;
  446.     my $interface = shift;
  447.     return keys %{$self->{interfaces}->{$interface}->{methods}};
  448. }
  449.  
  450. =item my @names = $ins->list_signals($interface)
  451.  
  452. Returns a list of all signals registered as being provided
  453. by the object, within the interface C<$interface>.
  454.  
  455. =cut
  456.  
  457. sub list_signals {
  458.     my $self = shift;
  459.     my $interface = shift;
  460.     return keys %{$self->{interfaces}->{$interface}->{signals}};
  461. }
  462.  
  463. =item my @names = $ins->list_properties($interface)
  464.  
  465. Returns a list of all properties registered as being provided
  466. by the object, within the interface C<$interface>.
  467.  
  468. =cut
  469.  
  470. sub list_properties {
  471.     my $self = shift;
  472.     my $interface = shift;
  473.     return keys %{$self->{interfaces}->{$interface}->{props}};
  474. }
  475.  
  476. =item my @paths = $self->list_children;
  477.  
  478. Returns a list of object paths representing all the children
  479. of this node.
  480.  
  481. =cut
  482.  
  483. sub list_children {
  484.     my $self = shift;
  485.     return @{$self->{children}};
  486. }
  487.  
  488. =item my $path = $ins->get_object_path
  489.  
  490. Returns the path of the object associated with this introspection
  491. data
  492.  
  493. =cut
  494.  
  495. sub get_object_path {
  496.     my $self = shift;
  497.     return $self->{object_path};
  498. }
  499.  
  500. =item my @types = $ins->get_method_params($interface, $name)
  501.  
  502. Returns a list of declared data types for parameters of the
  503. method called C<$name> within the interface C<$interface>.
  504.  
  505. =cut
  506.  
  507. sub get_method_params {
  508.     my $self = shift;
  509.     my $interface = shift;
  510.     my $method = shift;
  511.     return @{$self->{interfaces}->{$interface}->{methods}->{$method}->{params}};
  512. }
  513.  
  514. =item my @types = $ins->get_method_param_names($interface, $name)
  515.  
  516. Returns a list of declared names for parameters of the
  517. method called C<$name> within the interface C<$interface>.
  518.  
  519. =cut
  520.  
  521. sub get_method_param_names {
  522.     my $self = shift;
  523.     my $interface = shift;
  524.     my $method = shift;
  525.     return @{$self->{interfaces}->{$interface}->{methods}->{$method}->{paramnames}};
  526. }
  527.  
  528. =item my @types = $ins->get_method_returns($interface, $name)
  529.  
  530. Returns a list of declared data types for return values of the
  531. method called C<$name> within the interface C<$interface>.
  532.  
  533. =cut
  534.  
  535. sub get_method_returns {
  536.     my $self = shift;
  537.     my $interface = shift;
  538.     my $method = shift;
  539.     return @{$self->{interfaces}->{$interface}->{methods}->{$method}->{returns}};
  540. }
  541.  
  542. =item my @types = $ins->get_method_return_names($interface, $name)
  543.  
  544. Returns a list of declared names for return values of the
  545. method called C<$name> within the interface C<$interface>.
  546.  
  547. =cut
  548.  
  549. sub get_method_return_names {
  550.     my $self = shift;
  551.     my $interface = shift;
  552.     my $method = shift;
  553.     return @{$self->{interfaces}->{$interface}->{methods}->{$method}->{returnnames}};
  554. }
  555.  
  556. =item my @types = $ins->get_signal_params($interface, $name)
  557.  
  558. Returns a list of declared data types for values associated with the
  559. signal called C<$name> within the interface C<$interface>.
  560.  
  561. =cut
  562.  
  563. sub get_signal_params {
  564.     my $self = shift;
  565.     my $interface = shift;
  566.     my $signal = shift;
  567.     return @{$self->{interfaces}->{$interface}->{signals}->{$signal}->{params}};
  568. }
  569.  
  570. =item my @types = $ins->get_signal_param_names($interface, $name)
  571.  
  572. Returns a list of declared names for values associated with the
  573. signal called C<$name> within the interface C<$interface>.
  574.  
  575. =cut
  576.  
  577. sub get_signal_param_names {
  578.     my $self = shift;
  579.     my $interface = shift;
  580.     my $signal = shift;
  581.     return @{$self->{interfaces}->{$interface}->{signals}->{$signal}->{paramnames}};
  582. }
  583.  
  584. =item my $type = $ins->get_property_type($interface, $name)
  585.  
  586. Returns the declared data type for property called C<$name> within
  587. the interface C<$interface>.
  588.  
  589. =cut
  590.  
  591. sub get_property_type {
  592.     my $self = shift;
  593.     my $interface = shift;
  594.     my $prop = shift;
  595.     return $self->{interfaces}->{$interface}->{props}->{$prop}->{type};
  596. }
  597.  
  598. =item my $bool = $ins->is_property_readable($interface, $name);
  599.  
  600. Returns a true value if the property called C<$name> within the
  601. interface C<$interface> can have its value read.
  602.  
  603. =cut
  604.  
  605. sub is_property_readable {
  606.     my $self = shift;
  607.     my $interface = shift;
  608.     my $prop = shift;
  609.     my $access = $self->{interfaces}->{$interface}->{props}->{$prop}->{access};
  610.     return $access eq "readwrite" || $access eq "read" ? 1 : 0;
  611. }
  612.  
  613. =item my $bool = $ins->is_property_writable($interface, $name);
  614.  
  615. Returns a true value if the property called C<$name> within the
  616. interface C<$interface> can have its value written to.
  617.  
  618. =cut
  619.  
  620. sub is_property_writable {
  621.     my $self = shift;
  622.     my $interface = shift;
  623.     my $prop = shift;
  624.     my $access = $self->{interfaces}->{$interface}->{props}->{$prop}->{access};
  625.     return $access eq "readwrite" || $access eq "write" ? 1 : 0;
  626. }
  627.  
  628. sub _parse {
  629.     my $self = shift;
  630.     my $xml = shift;
  631.  
  632.     my $twig = XML::Twig->new();
  633.     $twig->parse($xml);
  634.  
  635.     $self->_parse_node($twig->root);
  636. }
  637.  
  638. sub _parse_node {
  639.     my $self = shift;
  640.     my $node = shift;
  641.  
  642.     $self->{object_path} = $node->att("name") if defined $node->att("name");
  643.     die "no object path provided" unless defined $self->{object_path};
  644.     $self->{children} = [];
  645.     foreach my $child ($node->children("interface")) {
  646.     $self->_parse_interface($child);
  647.     }
  648.     foreach my $child ($node->children("node")) {
  649.     if (!$child->has_children()) {
  650.         push @{$self->{children}}, $child->att("name");
  651.     } else {
  652.         push @{$self->{children}}, $self->new(node => $child);
  653.     }
  654.     }
  655. }
  656.  
  657. sub _parse_interface {
  658.     my $self = shift;
  659.     my $node = shift;
  660.  
  661.     my $name = $node->att("name");
  662.     $self->{interfaces}->{$name} = {
  663.     methods => {},
  664.     signals => {},
  665.     props => {},
  666.     };
  667.  
  668.     foreach my $child ($node->children("method")) {
  669.     $self->_parse_method($child, $name);
  670.     }
  671.     foreach my $child ($node->children("signal")) {
  672.     $self->_parse_signal($child, $name);
  673.     }
  674.     foreach my $child ($node->children("property")) {
  675.     $self->_parse_property($child, $name);
  676.     }
  677. }
  678.  
  679. sub _parse_method {
  680.     my $self = shift;
  681.     my $node = shift;
  682.     my $interface = shift;
  683.  
  684.     my $name = $node->att("name");
  685.     my @params;
  686.     my @returns;
  687.     my @paramnames;
  688.     my @returnnames;
  689.     my $deprecated = 0;
  690.     my $no_reply = 0;
  691.     foreach my $child ($node->children("arg")) {
  692.     my $type = $child->att("type");
  693.     my $direction = $child->att("direction");
  694.     my $name = $child->att("name");
  695.  
  696.     my @sig = split //, $type;
  697.     my @type = $self->_parse_type(\@sig);
  698.     if (!defined $direction || $direction eq "in") {
  699.         push @params, @type;
  700.         push @paramnames, $name;
  701.     } elsif ($direction eq "out") {
  702.         push @returns, @type;
  703.         push @returnnames, $name;
  704.     }
  705.     }
  706.     foreach my $child ($node->children("annotation")) {
  707.     my $name = $child->att("name");
  708.     my $value = $child->att("value");
  709.  
  710.     if ($name eq "org.freedesktop.DBus.Deprecated") {
  711.         $deprecated = 1 if lc($value) eq "true";
  712.     } elsif ($name eq "org.freedesktop.DBus.Method.NoReply") {
  713.         $no_reply = 1 if lc($value) eq "true";
  714.     }
  715.     }
  716.  
  717.     $self->{interfaces}->{$interface}->{methods}->{$name} = {
  718.     params => \@params,
  719.     returns => \@returns,
  720.     no_reply => $no_reply,
  721.     deprecated => $deprecated,
  722.     paramnames => \@paramnames,
  723.     returnnames => \@returnnames,
  724.     }
  725. }
  726.  
  727. sub _parse_type {
  728.     my $self = shift;
  729.     my $sig = shift;
  730.  
  731.     my $root = [];
  732.     my $current = $root;
  733.     my @cont;
  734.     while (my $type = shift @{$sig}) {
  735.     if (exists $simple_type_rev_map{ord($type)}) {
  736.         push @{$current}, $simple_type_rev_map{ord($type)};
  737.         if ($current->[0] eq "array") {
  738.         $current = pop @cont;
  739.         }
  740.     } else {
  741.         if ($type eq "(") {
  742.         my $new = ["struct"];
  743.         push @{$current}, $new;
  744.         push @cont, $current;
  745.         $current = $new;
  746.         } elsif ($type eq "a") {
  747.         my $new = ["array"];
  748.         push @cont, $current;
  749.         push @{$current}, $new;
  750.         $current = $new;
  751.         } elsif ($type eq "{") {
  752.         if ($current->[0] ne "array") {
  753.             die "dict must only occur within an array";
  754.         }
  755.         $current->[0] = "dict";
  756.         } elsif ($type eq ")") {
  757.         die "unexpected end of struct" unless
  758.             $current->[0] eq "struct";
  759.         $current = pop @cont;
  760.         if ($current->[0] eq "array") {
  761.             $current = pop @cont;
  762.         }
  763.         } elsif ($type eq "}") {
  764.         die "unexpected end of dict" unless
  765.             $current->[0] eq "dict";
  766.         $current = pop @cont;
  767.         if ($current->[0] eq "array") {
  768.             $current = pop @cont;
  769.         }
  770.         } elsif ($type eq "v") {
  771.         push @{$current}, ["variant"];
  772.         if ($current->[0] eq "array") {
  773.             $current = pop @cont;
  774.         }
  775.         } else {
  776.         die "unknown type sig '$type'";
  777.         }
  778.     }
  779.     }
  780.     return @{$root};
  781. }
  782.  
  783. sub _parse_signal {
  784.     my $self = shift;
  785.     my $node = shift;
  786.     my $interface = shift;
  787.  
  788.     my $name = $node->att("name");
  789.     my @params;
  790.     my @paramnames;
  791.     my $deprecated = 0;
  792.     foreach my $child ($node->children("arg")) {
  793.     my $type = $child->att("type");
  794.     my $name = $child->att("name");
  795.     my @sig = split //, $type;
  796.     my @type = $self->_parse_type(\@sig);
  797.     push @params, @type;
  798.     push @paramnames, $name;
  799.     }
  800.     foreach my $child ($node->children("annotation")) {
  801.     my $name = $child->att("name");
  802.     my $value = $child->att("value");
  803.  
  804.     if ($name eq "org.freedesktop.DBus.Deprecated") {
  805.         $deprecated = 1 if lc($value) eq "true";
  806.     }
  807.     }
  808.  
  809.     $self->{interfaces}->{$interface}->{signals}->{$name} = {
  810.     params => \@params,
  811.     paramnames => \@paramnames,
  812.     deprecated => $deprecated,
  813.     };
  814. }
  815.  
  816. sub _parse_property {
  817.     my $self = shift;
  818.     my $node = shift;
  819.     my $interface = shift;
  820.  
  821.     my $name = $node->att("name");
  822.     my $access = $node->att("access");
  823.     my $deprecated = 0;
  824.  
  825.     foreach my $child ($node->children("annotation")) {
  826.     my $name = $child->att("name");
  827.     my $value = $child->att("value");
  828.  
  829.     if ($name eq "org.freedesktop.DBus.Deprecated") {
  830.         $deprecated = 1 if lc($value) eq "true";
  831.     }
  832.     }
  833.     my @sig = split //, $node->att("type");
  834.     $self->{interfaces}->{$interface}->{props}->{$name} = {
  835.     type =>  $self->_parse_type(\@sig),
  836.     access => $access,
  837.     deprecated => $deprecated,
  838.     };
  839. }
  840.  
  841. =item my $xml = $ins->format([$obj])
  842.  
  843. Return a string containing an XML document representing the
  844. state of the introspection data. The optional C<$obj> parameter
  845. can be an instance of L<Net::DBus::Object> to include object
  846. specific information in the XML (eg child nodes).
  847.  
  848. =cut
  849.  
  850. sub format {
  851.     my $self = shift;
  852.     my $obj = shift;
  853.  
  854.     my $xml = '<!DOCTYPE node PUBLIC "-//freedesktop//DTD D-BUS Object Introspection 1.0//EN"' . "\n";
  855.     $xml .= '"http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd">' . "\n";
  856.  
  857.     return $xml . $self->to_xml("", $obj);
  858. }
  859.  
  860. =item my $xml_fragment = $ins->to_xml
  861.  
  862. Returns a string containing an XML fragment representing the
  863. state of the introspection data. This is basically the same
  864. as the C<format> method, but without the leading doctype
  865. declaration.
  866.  
  867. =cut
  868.  
  869. sub to_xml {
  870.     my $self = shift;
  871.     my $indent = shift;
  872.     my $obj = shift;
  873.  
  874.     my $xml = '';
  875.     my $path = $obj ? $obj->get_object_path : $self->{object_path};
  876.     unless (defined $path) {
  877.     die "no object_path for introspector, and no object supplied";
  878.     }
  879.     $xml .= $indent . '<node name="' . $path . '">' . "\n";
  880.  
  881.     foreach my $name (sort { $a cmp $b } keys %{$self->{interfaces}}) {
  882.     my $interface = $self->{interfaces}->{$name};
  883.     $xml .= $indent . '  <interface name="' . $name . '">' . "\n";
  884.     foreach my $mname (sort { $a cmp $b } keys %{$interface->{methods}}) {
  885.         my $method = $interface->{methods}->{$mname};
  886.         $xml .= $indent . '    <method name="' . $mname . '">' . "\n";
  887.  
  888.         my @paramnames = map{ $_ ? "name=\"$_\" " : '' } ( @{$method->{paramnames}} );
  889.         my @returnnames = map{ $_ ? "name=\"$_\" " : '' } ( @{$method->{returnnames}} );
  890.  
  891.         foreach my $type (@{$method->{params}}) {
  892.         next if ! ref($type) && exists $magic_type_map{$type};
  893.         $xml .= $indent . '      <arg ' . (@paramnames ? shift(@paramnames) : "")
  894.             . 'type="' . $self->to_xml_type($type) . '" direction="in"/>' . "\n";
  895.         }
  896.  
  897.         foreach my $type (@{$method->{returns}}) {
  898.         next if ! ref($type) && exists $magic_type_map{$type};
  899.         $xml .= $indent . '      <arg ' . (@returnnames ? shift(@returnnames) : "")
  900.             . 'type="' . $self->to_xml_type($type) . '" direction="out"/>' . "\n";
  901.         }
  902.         if ($method->{deprecated}) {
  903.         $xml .= $indent . '      <annotation name="org.freedesktop.DBus.Deprecated" value="true"/>' . "\n";
  904.         }
  905.         if ($method->{no_reply}) {
  906.         $xml .= $indent . '      <annotation name="org.freedesktop.DBus.Method.NoReply" value="true"/>' . "\n";
  907.         }
  908.         $xml .= $indent . '    </method>' . "\n";
  909.     }
  910.     foreach my $sname (sort { $a cmp $b } keys %{$interface->{signals}}) {
  911.         my $signal = $interface->{signals}->{$sname};
  912.         $xml .= $indent . '    <signal name="' . $sname . '">' . "\n";
  913.  
  914.         my @paramnames = map{ $_ ? "name=\"$_\" " : '' } ( @{$signal->{paramnames}} );
  915.  
  916.         foreach my $type (@{$signal->{params}}) {
  917.         next if ! ref($type) && exists $magic_type_map{$type};
  918.         $xml .= $indent . '      <arg ' . (@paramnames ? shift(@paramnames) : "")
  919.             . 'type="' . $self->to_xml_type($type) . '"/>' . "\n";
  920.         }
  921.         if ($signal->{deprecated}) {
  922.         $xml .= $indent . '      <annotation name="org.freedesktop.DBus.Deprecated" value="true"/>' . "\n";
  923.         }
  924.         $xml .= $indent . '    </signal>' . "\n";
  925.     }
  926.  
  927.     foreach my $pname (sort { $a cmp $b } keys %{$interface->{props}}) {
  928.         my $prop = $interface->{props}->{$pname};
  929.         my $type = $interface->{props}->{$pname}->{type};
  930.         my $access = $interface->{props}->{$pname}->{access};
  931.         if ($prop->{deprecated}) {
  932.         $xml .= $indent . '    <property name="' . $pname . '" type="' .
  933.             $self->to_xml_type($type) . '" access="' . $access . '">' . "\n";
  934.         $xml .= $indent . '      <annotation name="org.freedesktop.DBus.Deprecated" value="true"/>' . "\n";
  935.         $xml .= $indent . '    </property>' . "\n";
  936.         } else {
  937.         $xml .= $indent . '    <property name="' . $pname . '" type="' .
  938.             $self->to_xml_type($type) . '" access="' . $access . '"/>' . "\n";
  939.         }
  940.     }
  941.  
  942.     $xml .= $indent . '  </interface>' . "\n";
  943.     }
  944.  
  945.     #
  946.     # Interfaces don't have children,  objects do
  947.     #
  948.     if ($obj) {
  949.     foreach ( $obj->_get_sub_nodes ) {
  950.         $xml .= $indent . '  <node name="/' . $_ . '"/>' . "\n";
  951.     }
  952.     } else {
  953.     foreach my $child (@{$self->{children}}) {
  954.         if (ref($child) eq __PACKAGE__) {
  955.         $xml .= $child->to_xml($indent . "  ");
  956.         } else {
  957.         $xml .= $indent . '  <node name="' . $child . '"/>' . "\n";
  958.         }
  959.     }
  960.     }
  961.  
  962.     $xml .= $indent . "</node>\n";
  963. }
  964.  
  965. =item $type = $ins->to_xml_type($type)
  966.  
  967. Takes a text-based representation of a data type and returns
  968. the compact representation used in XML introspection data.
  969.  
  970. =cut
  971.  
  972. sub to_xml_type {
  973.     my $self = shift;
  974.     my $type = shift;
  975.  
  976.     my $sig = '';
  977.     if (ref($type) eq "ARRAY") {
  978.     if ($type->[0] eq "array") {
  979.         if ($#{$type} != 1) {
  980.         die "array spec must contain only 1 type";
  981.         }
  982.         $sig .= chr($compound_type_map{$type->[0]});
  983.         $sig .= $self->to_xml_type($type->[1]);
  984.     } elsif ($type->[0] eq "struct") {
  985.         $sig .= "(";
  986.         for (my $i = 1 ; $i <= $#{$type} ; $i++) {
  987.         $sig .= $self->to_xml_type($type->[$i]);
  988.         }
  989.         $sig .= ")";
  990.     } elsif ($type->[0] eq "dict") {
  991.         if ($#{$type} != 2) {
  992.         die "dict spec must contain only 2 types";
  993.         }
  994.         $sig .= chr($compound_type_map{"array"});
  995.         $sig .= "{";
  996.         $sig .= $self->to_xml_type($type->[1]);
  997.         $sig .= $self->to_xml_type($type->[2]);
  998.         $sig .= "}";
  999.     } elsif ($type->[0] eq "variant") {
  1000.         if ($#{$type} != 0) {
  1001.         die "dict spec must contain no sub-types";
  1002.         }
  1003.         $sig .= chr($compound_type_map{"variant"});
  1004.     } else {
  1005.         die "unknown/unsupported compound type " . $type->[0] . " expecting 'array', 'struct', or 'dict'";
  1006.     }
  1007.     } else {
  1008.     die "unknown/unsupported scalar type '$type'"
  1009.         unless exists $simple_type_map{$type};
  1010.     $sig .= chr($simple_type_map{$type});
  1011.     }
  1012.     return $sig;
  1013. }
  1014.  
  1015. =item $ins->encode($message, $type, $name, $direction, @args)
  1016.  
  1017. Append a set of values <@args> to a message object C<$message>.
  1018. The C<$type> parameter is either C<signal> or C<method> and
  1019. C<$direction> is either C<params> or C<returns>. The introspection
  1020. data will be queried to obtain the declared data types & the
  1021. argument marshalling accordingly.
  1022.  
  1023. =cut
  1024.  
  1025. sub encode {
  1026.     my $self = shift;
  1027.     my $message = shift;
  1028.     my $type = shift;
  1029.     my $name = shift;
  1030.     my $direction = shift;
  1031.     my @args = @_;
  1032.  
  1033.     my $interface = $message->get_interface;
  1034.  
  1035.     my @types;
  1036.     if ($interface) {
  1037.     if (exists $self->{interfaces}->{$interface}) {
  1038.         if (exists $self->{interfaces}->{$interface}->{$type}->{$name}) {
  1039.         @types = @{$self->{interfaces}->{$interface}->{$type}->{$name}->{$direction}};
  1040.         } else {
  1041.         warn "missing introspection data when encoding $type '$name' in object " .
  1042.             $self->get_object_path . "\n" if $debug;
  1043.         }
  1044.     } else {
  1045.         warn "missing interface '$interface' in introspection data for object '" .
  1046.         $self->get_object_path . "' encoding $type '$name'\n" if $debug;
  1047.     }
  1048.     } else {
  1049.     foreach my $in (keys %{$self->{interfaces}}) {
  1050.         if (exists $self->{interfaces}->{$in}->{$type}->{$name}) {
  1051.         $interface = $in;
  1052.         }
  1053.     }
  1054.     if ($interface) {
  1055.         @types = @{$self->{interfaces}->{$interface}->{$type}->{$name}->{$direction}};
  1056.     } else {
  1057.         warn "no interface in introspection data for object " .
  1058.         $self->get_object_path . " encoding $type '$name'\n" if $debug;
  1059.     }
  1060.     }
  1061.  
  1062.     # If you don't explicitly 'return ()' from methods, Perl
  1063.     # will always return a single element representing the
  1064.     # return value of the last command executed in the method.
  1065.     # To avoid this causing a PITA for methods exported with
  1066.     # no return values, we throw away returns instead of dieing
  1067.     if ($direction eq "returns" &&
  1068.     $#types == -1 &&
  1069.     $#args != -1) {
  1070.     @args = ();
  1071.     }
  1072.  
  1073.     # No introspection data available, then just fallback
  1074.     # to a plain (guess types) append
  1075.     unless (@types) {
  1076.     $message->append_args_list(@args);
  1077.     return;
  1078.     }
  1079.  
  1080.  
  1081.     die "expected " . int(@types) . " $direction, but got " . int(@args)
  1082.     unless $#types == $#args;
  1083.  
  1084.     my $iter = $message->iterator(1);
  1085.     foreach my $t ($self->_convert(@types)) {
  1086.     $iter->append(shift @args, $t);
  1087.     }
  1088. }
  1089.  
  1090. sub _convert {
  1091.     my $self = shift;
  1092.     my @in = @_;
  1093.  
  1094.     my @out;
  1095.     foreach my $in (@in) {
  1096.     if (ref($in) eq "ARRAY") {
  1097.         my @subtype = @{$in};
  1098.         shift @subtype;
  1099.         my @subout = $self->_convert(@subtype);
  1100.         die "unknown compound type " . $in->[0] unless
  1101.         exists $compound_type_map{lc $in->[0]};
  1102.  
  1103.         push @out, [$compound_type_map{lc $in->[0]}, \@subout];
  1104.     } elsif (exists $magic_type_map{lc $in}) {
  1105.         push @out, $magic_type_map{lc $in};
  1106.     } else {
  1107.         die "unknown simple type " . $in unless
  1108.         exists $simple_type_map{lc $in};
  1109.         push @out, $simple_type_map{lc $in};
  1110.     }
  1111.     }
  1112.     return @out;
  1113. }
  1114.  
  1115. =item my @args = $ins->decode($message, $type, $name, $direction)
  1116.  
  1117. Unmarshalls the contents of a message object C<$message>.
  1118. The C<$type> parameter is either C<signal> or C<method> and
  1119. C<$direction> is either C<params> or C<returns>. The introspection
  1120. data will be queried to obtain the declared data types & the
  1121. arguments unmarshalled accordingly.
  1122.  
  1123. =cut
  1124.  
  1125. sub decode {
  1126.     my $self = shift;
  1127.     my $message = shift;
  1128.     my $type = shift;
  1129.     my $name = shift;
  1130.     my $direction = shift;
  1131.  
  1132.     my $interface = $message->get_interface;
  1133.  
  1134.     my @types;
  1135.     if ($interface) {
  1136.     if (exists $self->{interfaces}->{$interface}) {
  1137.         if (exists $self->{interfaces}->{$interface}->{$type}->{$name}) {
  1138.             @types =
  1139.             @{$self->{interfaces}->{$interface}->{$type}->{$name}->{$direction}};
  1140.         } else {
  1141.         warn "missing introspection data when decoding $type '$name' in object " .
  1142.             $self->get_object_path . "\n" if $debug;
  1143.         }
  1144.     } else {
  1145.         warn "missing interface '$interface' in introspection data for object '" .
  1146.         $self->get_object_path . "' when decoding $type '$name'\n" if $debug;
  1147.     }
  1148.     } else {
  1149.     foreach my $in (keys %{$self->{interfaces}}) {
  1150.         if (exists $self->{interfaces}->{$in}->{$type}->{$name}) {
  1151.         $interface = $in;
  1152.         }
  1153.     }
  1154.     if (!$interface) {
  1155.         warn "no interface in introspection data for object " .
  1156.         $self->get_object_path . " decoding $type '$name'\n" if $debug;
  1157.     } else {
  1158.         @types =
  1159.         @{$self->{interfaces}->{$interface}->{$type}->{$name}->{$direction}};
  1160.     }
  1161.     }
  1162.  
  1163.     # If there are no types defined, just return the
  1164.     # actual data from the message, assuming the introspection
  1165.     # data was partial.
  1166.     return $message->get_args_list
  1167.     unless @types;
  1168.  
  1169.     my $iter = $message->iterator;
  1170.  
  1171.     my $hasnext = 1;
  1172.     my @rawtypes = $self->_convert(@types);
  1173.     my @ret;
  1174.     while (@types) {
  1175.     my $type = shift @types;
  1176.     my $rawtype = shift @rawtypes;
  1177.  
  1178.     if (exists $magic_type_map{$type}) {
  1179.         push @ret, &$rawtype($message);
  1180.     } elsif ($hasnext) {
  1181.         push @ret, $iter->get($rawtype);
  1182.         $hasnext = $iter->next;
  1183.     }
  1184.     }
  1185.     return @ret;
  1186. }
  1187.  
  1188. 1;
  1189.  
  1190. =pod
  1191.  
  1192. =back
  1193.  
  1194. =head1 SEE ALSO
  1195.  
  1196. L<Net::DBus::Exporter>, L<Net::DBus::Binding::Message>
  1197.  
  1198. =head1 AUTHOR
  1199.  
  1200. Daniel Berrange E<lt>dan@berrange.comE<gt>
  1201.  
  1202. =head1 COPYRIGHT
  1203.  
  1204. Copyright 2004 by Daniel Berrange
  1205.  
  1206. =cut
  1207.